
;
;  Simple dumper to write display the content of the VM stack
;  This is a PreScheme package, so it works in the compiled VM as well
;
; Usage:
;   - load the debug-package.scm when loading/compiling the VM
;   - open the vm-stack-debug package
;   - insert a call to (dump-stack (current-error-port)) where needed
; 
;
;  The output can be customized with the settings below
;

(define *nesting-limit* 2) ; limit the display of nested data
(define *element-limit* 3) ; limit the amount of elements to display from vectors etc
(define *hide-stob-content* #t) ; hide stob content or not


(define (dump-stack port)
  (dump-stack-part (a-units->cells (address-difference *stack-end* *stack*)) port))


(define (dump-stack-part cells port)
  (let loop ((index 0) (addr *stack*) (cont *cont*))
    (newline port)    
    (cond ((>= index cells)
           (unspecific))
          ((address= addr cont)
           (write-index index port)  
           (write-string "#{stack-continuation}" port)
           (write-references addr port)
           (loop (+ index 1) (address+ addr (cells->a-units 1)) (stack-cont-continuation cont)))
          (else
           (write-index index port)  
           (write-thing (stack-ref index) 0 port)
           (write-references addr port)
           (loop (+ index 1) (address+ addr (cells->a-units 1)) cont)))))
    

(define (write-index index port)
  (cond ((< index 10)
         (write-string "    " port))
        ((< index 100)
         (write-string "   " port))
        ((< index 1000)
         (write-string "  " port))
        (else
         (write-string " " port)))
  (write-integer index port)
  (write-char #\: port)
  (write-char #\space port))         


(define (write-references address port)
  (maybe-write-reference address *stack-begin* "*stack-begin*" port)
  (maybe-write-reference address *stack-end* "*stack-end*" port)
  (maybe-write-reference address *real-stack-limit* "*real-stack-limit*" port)
  (maybe-write-reference address *cont* "*cont*" port)
  (maybe-write-reference address *registers* "*registers*" port)
  (maybe-write-reference address *stack* "*stack*" port)
  (maybe-write-reference address *bottom-of-stack* "*bottom-of-stack*" port))


(define (maybe-write-reference address ref name port)
  (if (address= address ref)
      (begin
        (write-string " <- " port)
        (write-string name port)
        (unspecific))))


(define (write-thing thing nesting port)
  (cond ((vm-eq? thing stack-marker)
         (write-string "unassigned stack marker" port))
        ((fixnum? thing)
	 (write-integer (extract-fixnum thing) port))
	((vm-char? thing)
	 (write-string "#\\" port)
	 (write-char (ascii->char (vm-char->scalar-value thing)) port))
	((vm-string? thing)
	 (write-char #\" port)
	 (write-vm-string thing port)
	 (write-char #\" port))
	((vm-symbol? thing)
	 (write-vm-string (vm-symbol->string thing) port))	 	 
	((vm-vector? thing)
	 (write-char #\# port)
	 (write-char #\( port)
	 (cond ((= 0 (vm-vector-length thing))
	        (unspecific))
	       ((> nesting *nesting-limit*)
	        (write-string "..." port)
	        (unspecific))
	       (else
	        (let loop ((i 0))
	          (cond ((>= i (vm-vector-length thing))
	                 (unspecific))
	                ((>= i *element-limit*)
	                 (write-string " ..." port)
	                 (unspecific))	                
	                ((= i 0)
	                 (write-thing (vm-vector-ref thing i) (+ nesting 1) port)
	                 (loop (+ i 1)))
	                (else
	                 (write-char #\space port)
	                 (write-thing (vm-vector-ref thing i) (+ nesting 1) port)
	                 (loop (+ i 1))))))) 
	 (write-char #\) port))	
	((vm-pair? thing)  ; does not handle circular lists!
	 (write-char #\( port)
	 (if (> nesting *nesting-limit*)
	     (begin
	       (write-string "..." port)
	       (unspecific))
             (let loop ((l thing) (c 1))
               (write-thing (vm-car thing) (+ nesting 1) port)
               (cond ((vm-eq? thing null)
                      (unspecific))
                     ((not (vm-pair? (vm-cdr thing))) 
                      (write-string " . " port)
                      (write-thing (vm-cdr thing) (+ nesting 1) port)
                      (unspecific))
                     ((> c *element-limit*)
                      (write-string " ..." port)
                      (unspecific))                      
                     (else
                      (write-char #\space port)
                      (loop (vm-cdr thing) (+ c 1))))))
	 (write-char #\) port))	
	((stob? thing)
	 (write-string "#{" port)
	 (write-string (stob-name thing) port)
	 (cond (*hide-stob-content*
	        (unspecific))
	       ((> nesting *nesting-limit*)
	        (write-string " ..." port)
	        (unspecific))
	       ((d-vector? thing)
	        (let loop ((i 0))
	          (cond ((>= i *element-limit*)
	                 (write-string " ..." port)
	                 (unspecific))
	                ((< i (d-vector-length thing))
	                 (write-char #\space port)
	                 (write-thing (d-vector-ref thing i) (+ nesting 1) port)
	                 (loop (+ i 1)))
	                (else
	                 (unspecific)))))
	       (else
	        (let loop ((i 0))
	          (cond ((>= i *element-limit*)
	                 (write-string " ..." port)
	                 (unspecific))
	                ((< i (b-vector-length thing))
	                 (write-char #\space port)
	                 (write-integer (b-vector-ref thing i) port)
	                 (loop (+ i 1)))
	                (else
	                 (unspecific))))))      
	 (write-char #\} port))
	(else
	 (write-string (cond ((vm-boolean? thing)
			      (if (extract-boolean thing) "#t" "#f"))
			     ((vm-eq? thing null)
			      "()")
			     ((code-vector? thing)
			      "#{code-vector}")
			     (else
			      "???"))
		       port))))

(define (d-vector? obj)
  (and (stob? obj)
       (< (header-type (stob-header obj)) least-b-vector-type)))

; need to sync with arch.scm
;
(define (stob-name thing)
  (cond ((vm-pair? thing) "pair")
        ((vm-symbol? thing) "symbol")  
        ((vm-vector? thing) "vector")
        ((closure? thing) "closure")
        ((location? thing) "location")
        ((cell? thing) "cell")
        ((channel? thing) "channel")
        ((port? thing) "port")
        ((ratnum? thing) "ratnum")
        ((record? thing) "record")                
        ((continuation? thing) "continuation")
        ((extended-number? thing) "extended-number")
        ((template? thing) "template")
        ((weak-pointer? thing) "weak-pointer")
        ((shared-binding? thing) "shared-binding")
        ((transport-link-cell? thing) "transport-link-cell")
        ((vm-string? thing) "string")
        ((code-vector? thing) "byte-vector")
        ((double? thing) "double")
        ((bignum? thing) "bignum")
        (else "unknown-stob")))
